home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / vms / ext / Stdio / Stdio.xs < prev    next >
Text File  |  1998-07-20  |  11KB  |  393 lines
  1. /* VMS::Stdio - VMS extensions to stdio routines 
  2.  *
  3.  * Version:  2.1
  4.  * Author:   Charles Bailey  bailey@genetics.upenn.edu
  5.  * Revised:  24-Mar-1998
  6.  *
  7.  */
  8.  
  9. #include "EXTERN.h"
  10. #include "perl.h"
  11. #include "XSUB.h"
  12. #include <file.h>
  13. #include <iodef.h>
  14. #include <rms.h>
  15. #include <starlet.h>
  16.  
  17. static bool
  18. constant(name, pval)
  19. char *name;
  20. IV *pval;
  21. {
  22.     if (strnNE(name, "O_", 2)) return FALSE;
  23.  
  24.     if (strEQ(name, "O_APPEND"))
  25. #ifdef O_APPEND
  26.     { *pval = O_APPEND; return TRUE; }
  27. #else
  28.     return FALSE;
  29. #endif
  30.     if (strEQ(name, "O_CREAT"))
  31. #ifdef O_CREAT
  32.     { *pval = O_CREAT; return TRUE; }
  33. #else
  34.     return FALSE;
  35. #endif
  36.     if (strEQ(name, "O_EXCL"))
  37. #ifdef O_EXCL
  38.     { *pval = O_EXCL; return TRUE; }
  39. #else
  40.     return FALSE;
  41. #endif
  42.     if (strEQ(name, "O_NDELAY"))
  43. #ifdef O_NDELAY
  44.     { *pval = O_NDELAY; return TRUE; }
  45. #else
  46.     return FALSE;
  47. #endif
  48.     if (strEQ(name, "O_NOWAIT"))
  49. #ifdef O_NOWAIT
  50.     { *pval = O_NOWAIT; return TRUE; }
  51. #else
  52.     return FALSE;
  53. #endif
  54.     if (strEQ(name, "O_RDONLY"))
  55. #ifdef O_RDONLY
  56.     { *pval = O_RDONLY; return TRUE; }
  57. #else
  58.     return FALSE;
  59. #endif
  60.     if (strEQ(name, "O_RDWR"))
  61. #ifdef O_RDWR
  62.     { *pval = O_RDWR; return TRUE; }
  63. #else
  64.     return FALSE;
  65. #endif
  66.     if (strEQ(name, "O_TRUNC"))
  67. #ifdef O_TRUNC
  68.     { *pval = O_TRUNC; return TRUE; }
  69. #else
  70.     return FALSE;
  71. #endif
  72.     if (strEQ(name, "O_WRONLY"))
  73. #ifdef O_WRONLY
  74.     { *pval = O_WRONLY; return TRUE; }
  75. #else
  76.     return FALSE;
  77. #endif
  78.  
  79.     return FALSE;
  80. }
  81.  
  82.  
  83. static SV *
  84. newFH(FILE *fp, char type) {
  85.     SV *rv;
  86.     GV **stashp, *gv = (GV *)NEWSV(0,0);
  87.     HV *stash;
  88.     IO *io;
  89.  
  90.     dTHR;
  91.     /* Find stash for VMS::Stdio.  We don't do this once at boot
  92.      * to allow for possibility of threaded Perl with per-thread
  93.      * symbol tables.  This code (through io = ...) is really
  94.      * equivalent to gv_fetchpv("VMS::Stdio::__FH__",TRUE,SVt_PVIO),
  95.      * with a little less overhead, and good exercise for me. :-) */
  96.     stashp = (GV **)hv_fetch(PL_defstash,"VMS::",5,TRUE);
  97.     if (!stashp || *stashp == (GV *)&PL_sv_undef) return Nullsv;
  98.     if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
  99.     stashp = (GV **)hv_fetch(GvHV(*stashp),"Stdio::",7,TRUE);
  100.     if (!stashp || *stashp == (GV *)&PL_sv_undef) return Nullsv;
  101.     if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
  102.  
  103.     /* Set up GV to point to IO, and then take reference */
  104.     gv_init(gv,stash,"__FH__",6,0);
  105.     io = GvIOp(gv) = newIO();
  106.     IoIFP(io) = fp;
  107.     if (type != '<') IoOFP(io) = fp;
  108.     IoTYPE(io) = type;
  109.     rv = newRV((SV *)gv);
  110.     SvREFCNT_dec(gv);
  111.     return sv_bless(rv,stash);
  112. }
  113.  
  114. MODULE = VMS::Stdio  PACKAGE = VMS::Stdio
  115.  
  116. void
  117. constant(name)
  118.     char *    name
  119.     PROTOTYPE: $
  120.     CODE:
  121.     IV i;
  122.     if (constant(name, &i))
  123.         ST(0) = sv_2mortal(newSViv(i));
  124.     else
  125.         ST(0) = &PL_sv_undef;
  126.  
  127. void
  128. flush(fp)
  129.     FILE *    fp
  130.     PROTOTYPE: $
  131.     CODE:
  132.         if (fflush(fp)) { ST(0) = &PL_sv_undef; }
  133.         else            { clearerr(fp); ST(0) = &PL_sv_yes; }
  134.  
  135. char *
  136. getname(fp)
  137.     FILE *    fp
  138.     PROTOTYPE: $
  139.     CODE:
  140.         char fname[NAM$C_MAXRSS+1];
  141.         ST(0) = sv_newmortal();
  142.         if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
  143.  
  144. void
  145. rewind(fp)
  146.     FILE *    fp
  147.     PROTOTYPE: $
  148.     CODE:
  149.         ST(0) = rewind(fp) ? &PL_sv_undef : &PL_sv_yes;
  150.  
  151. void
  152. remove(name)
  153.     char *name
  154.     PROTOTYPE: $
  155.     CODE:
  156.         ST(0) = remove(name) ? &PL_sv_undef : &PL_sv_yes;
  157.  
  158. void
  159. setdef(...)
  160.     PROTOTYPE: @
  161.     CODE:
  162.         char vmsdef[NAM$C_MAXRSS+1], es[NAM$C_MAXRSS], sep;
  163.         unsigned long int retsts;
  164.         struct FAB deffab = cc$rms_fab;
  165.         struct NAM defnam = cc$rms_nam;
  166.         struct dsc$descriptor_s dirdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
  167.         if (items) {
  168.         SV *defsv = ST(items-1);  /* mimic chdir() */
  169.         ST(0) = &PL_sv_undef;
  170.         if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); }
  171.         if (tovmsspec(SvPV(defsv,PL_na),vmsdef) == NULL) { XSRETURN(1); }
  172.         deffab.fab$l_fna = vmsdef; deffab.fab$b_fns = strlen(vmsdef);
  173.         }
  174.         else {
  175.         deffab.fab$l_fna = "SYS$LOGIN"; deffab.fab$b_fns = 9;
  176.         EXTEND(sp,1);  ST(0) = &PL_sv_undef;
  177.         }
  178.         defnam.nam$l_esa = es;  defnam.nam$b_ess = sizeof es;
  179.         deffab.fab$l_nam = &defnam;
  180.         retsts = sys$parse(&deffab,0,0);
  181.         if (retsts & 1) {
  182.         if (defnam.nam$v_wildcard) retsts = RMS$_WLD;
  183.         else if (defnam.nam$b_name || defnam.nam$b_type > 1 ||
  184.                  defnam.nam$b_ver > 1) retsts = RMS$_DIR;
  185.         }
  186.         defnam.nam$b_nop |= NAM$M_SYNCHK; defnam.nam$l_rlf = NULL; deffab.fab$b_dns = 0;
  187.         if (!(retsts & 1)) {
  188.         set_vaxc_errno(retsts);
  189.         switch (retsts) {
  190.             case RMS$_DNF:
  191.             set_errno(ENOENT); break;
  192.             case RMS$_SYN: case RMS$_DIR: case RMS$_DEV:
  193.             set_errno(EINVAL); break;
  194.             case RMS$_PRV:
  195.             set_errno(EACCES); break;
  196.             default:
  197.             set_errno(EVMSERR); break;
  198.         }
  199.         (void) sys$parse(&deffab,0,0);  /* free up context */
  200.         XSRETURN(1);
  201.         }
  202.         sep = *defnam.nam$l_dir;
  203.         *defnam.nam$l_dir = '\0';
  204.         my_setenv("SYS$DISK",defnam.nam$b_node ? defnam.nam$l_node : defnam.nam$l_dev);
  205.         *defnam.nam$l_dir = sep;
  206.         dirdsc.dsc$a_pointer = defnam.nam$l_dir; dirdsc.dsc$w_length = defnam.nam$b_dir;
  207.         if ((retsts = sys$setddir(&dirdsc,0,0)) & 1) ST(0) = &PL_sv_yes;
  208.         else { set_errno(EVMSERR); set_vaxc_errno(retsts); }
  209.         (void) sys$parse(&deffab,0,0);  /* free up context */
  210.  
  211. void
  212. sync(fp)
  213.     FILE *    fp
  214.     PROTOTYPE: $
  215.     CODE:
  216.         if (fsync(fileno(fp))) { ST(0) = &PL_sv_undef; }
  217.         else                   { clearerr(fp); ST(0) = &PL_sv_yes; }
  218.  
  219. char *
  220. tmpnam()
  221.     PROTOTYPE:
  222.     CODE:
  223.         char fname[L_tmpnam];
  224.         ST(0) = sv_newmortal();
  225.         if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);
  226.  
  227. void
  228. vmsopen(spec,...)
  229.     char *    spec
  230.     PROTOTYPE: @
  231.     CODE:
  232.         char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
  233.         register int i, myargc;
  234.         FILE *fp;
  235.     
  236.         if (!spec || !*spec) {
  237.            SETERRNO(EINVAL,LIB$_INVARG);
  238.            XSRETURN_UNDEF;
  239.         }
  240.         if (items > 9) croak("too many args");
  241.     
  242.         /* First, set up name and mode args from perl's string */
  243.         if (*spec == '+') {
  244.           mode[1] = '+';
  245.           spec++;
  246.         }
  247.         if (*spec == '>') {
  248.           if (*(spec+1) == '>') *mode = 'a', spec += 2;
  249.           else *mode = 'w',  spec++;
  250.         }
  251.         else if (*spec == '<') spec++;
  252.         myargc = items - 1;
  253.         for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),PL_na);
  254.         /* This hack brought to you by C's opaque arglist management */
  255.         switch (myargc) {
  256.           case 0:
  257.             fp = fopen(spec,mode);
  258.             break;
  259.           case 1:
  260.             fp = fopen(spec,mode,args[0]);
  261.             break;
  262.           case 2:
  263.             fp = fopen(spec,mode,args[0],args[1]);
  264.             break;
  265.           case 3:
  266.             fp = fopen(spec,mode,args[0],args[1],args[2]);
  267.             break;
  268.           case 4:
  269.             fp = fopen(spec,mode,args[0],args[1],args[2],args[3]);
  270.             break;
  271.           case 5:
  272.             fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]);
  273.             break;
  274.           case 6:
  275.             fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
  276.             break;
  277.           case 7:
  278.             fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
  279.             break;
  280.           case 8:
  281.             fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
  282.             break;
  283.         }
  284.         if (fp != Nullfp) {
  285.           SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
  286.           ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
  287.         }
  288.         else { ST(0) = &PL_sv_undef; }
  289.  
  290. void
  291. vmssysopen(spec,mode,perm,...)
  292.     char *    spec
  293.     int    mode
  294.     int    perm
  295.     PROTOTYPE: @
  296.     CODE:
  297.         char *args[8];
  298.         int i, myargc, fd;
  299.         FILE *fp;
  300.         SV *fh;
  301.         if (!spec || !*spec) {
  302.            SETERRNO(EINVAL,LIB$_INVARG);
  303.            XSRETURN_UNDEF;
  304.         }
  305.         if (items > 11) croak("too many args");
  306.         myargc = items - 3;
  307.         for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),PL_na);
  308.         /* More fun with C calls; can't combine with above because
  309.            args 2,3 of different types in fopen() and open() */
  310.         switch (myargc) {
  311.           case 0:
  312.             fd = open(spec,mode,perm);
  313.             break;
  314.           case 1:
  315.             fd = open(spec,mode,perm,args[0]);
  316.             break;
  317.           case 2:
  318.             fd = open(spec,mode,perm,args[0],args[1]);
  319.             break;
  320.           case 3:
  321.             fd = open(spec,mode,perm,args[0],args[1],args[2]);
  322.             break;
  323.           case 4:
  324.             fd = open(spec,mode,perm,args[0],args[1],args[2],args[3]);
  325.             break;
  326.           case 5:
  327.             fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4]);
  328.             break;
  329.           case 6:
  330.             fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5]);
  331.             break;
  332.           case 7:
  333.             fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
  334.             break;
  335.           case 8:
  336.             fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
  337.             break;
  338.         }
  339.         i = mode & 3;
  340.         if (fd >= 0 &&
  341.            ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Nullfp)) {
  342.           SV *fh = newFH(fp,"<>++"[i]);
  343.           ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
  344.         }
  345.         else { ST(0) = &PL_sv_undef; }
  346.  
  347. void
  348. waitfh(fp)
  349.     FILE *    fp
  350.     PROTOTYPE: $
  351.     CODE:
  352.         ST(0) = fwait(fp) ? &PL_sv_undef : &PL_sv_yes;
  353.  
  354. void
  355. writeof(mysv)
  356.     SV *    mysv
  357.     PROTOTYPE: $
  358.     CODE:
  359.         char devnam[257], *cp;
  360.         unsigned long int chan, iosb[2], retsts, retsts2;
  361.         struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
  362.         IO *io = sv_2io(mysv);
  363.         FILE *fp = io ? IoOFP(io) : NULL;
  364.         if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) {
  365.           set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN);
  366.           ST(0) = &PL_sv_undef;  XSRETURN(1);
  367.         }
  368.         if (fgetname(fp,devnam) == Nullch) { ST(0) = &PL_sv_undef; XSRETURN(1); }
  369.         if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
  370.         devdsc.dsc$w_length = strlen(devnam);
  371.         retsts = sys$assign(&devdsc,&chan,0,0);
  372.         if (retsts & 1) retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
  373.         if (retsts & 1) retsts = iosb[0];
  374.         retsts2 = sys$dassgn(chan);  /* Be sure to deassign the channel */
  375.         if (retsts & 1) retsts = retsts2;
  376.         if (retsts & 1) { ST(0) = &PL_sv_yes; }
  377.         else {
  378.           set_vaxc_errno(retsts);
  379.           switch (retsts) {
  380.             case SS$_EXQUOTA:  case SS$_INSFMEM:  case SS$_MBFULL:
  381.             case SS$_MBTOOSML: case SS$_NOIOCHAN: case SS$_NOLINKS:
  382.             case SS$_BUFFEROVF:
  383.               set_errno(ENOSPC); break;
  384.             case SS$_ILLIOFUNC: case SS$_DEVOFFLINE: case SS$_NOSUCHDEV:
  385.               set_errno(EBADF);  break;
  386.             case SS$_NOPRIV:
  387.               set_errno(EACCES); break;
  388.             default:  /* Includes "shouldn't happen" cases that might map */
  389.               set_errno(EVMSERR); break;         /* to other errno values */
  390.           }
  391.           ST(0) = &PL_sv_undef;
  392.         }
  393.